Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/MacBinary II+ 1.0.0/source/MacBinary II+.p

Text File | 1992-12-06 | 18.8 KB | 772 lines | [TEXT/PJMM]

program MacBinary2Plus;

    uses
        Tasks, AppleEvents, MyTypes, MyAppleEvents, MyMemory, MyMacBinary, {}
        CRCs, MyDesktopDB, MyFDFlags, Displays;

    const
        macbin_creator = 'MB2P';
        macbin_ftype = 'TEXT';
        errFormatError = -5;
        abortError = 3;
        clear_flags = fdLocked + fdInvisible;

    var
        quitNow, quitWhenDone, launchedwithoption: boolean;
        has_AppleEvents: boolean;
        files: integer;

    procedure DoQuit;
    begin
        quitNow := true;
    end;

    function DoOApp: OSErr;
    begin
        quitNow := true;
        DoOApp := noErr;
    end;

    procedure Yield;
        var
            oe: OSErr;
    begin
        oe := TaskYield;
    end;

    procedure FailError (oe: OSErr);
        var
            s: str255;
            a: integer;
    begin
        if oe <> abortError then begin
            NumToString(oe, s);
            ParamText(s, '', '', '');
            a := Alert(128, nil);
        end;
    end;

    procedure SetSFFile (fs: FSSpec);
    begin
        integerP(SFSaveDiskA)^ := -fs.vRefNum;
        longIntP(CurDirStoreA)^ := fs.parID;
    end;

    function GetOutput (var fs: FSSpec): boolean;
        var
            reply: StandardFileReply;
    begin
        SetSFFile(fs);
        StandardPutFile('Save file/folder:', fs.name, reply);
        fs := reply.sfFile;
        GetOutput := reply.sfGood;
    end;

    procedure SanitizeName (var name: string);
        var
            i: integer;
    begin
        for i := 1 to length(name) do
            if name[i] in [nul, ':'] then
                name[i] := '-';
        if (length(name) > 0) & (name[1] = '.') then
            name[1] := '•';
    end;

    function CreateUniqueFile (var fs: FSSPec; creator, ftype: OSType): OSErr;
{ Try fs.name }
{ Otherwise, try fs.name#index until it succeeds (or fails for another reason) }
        var
            oname: str31;
            n: str255;
            i: integer;
            oe: OSErr;
    begin
        SanitizeName(fs.name);
        oname := fs.name;
        oe := FSpCreate(fs, creator, ftype, 0);
        i := 1;
        while oe = dupFNErr do begin
            NumToString(i, n);
            fs.name := concat(copy(oname, 1, 27), '#', n);
            oe := FSpCreate(fs, creator, ftype, 0);
            i := i + 1;
        end;
        CreateUniqueFile := oe;
    end;

    function CreateUniqueDir (var fs: FSSPec; var dirID: longInt): OSErr;
{ Try fs.name }
{ Otherwise, try fs.name#index until it succeeds (or fails for another reason) }
        var
            oname: str31;
            n: str255;
            i: integer;
            oe: OSErr;
    begin
        SanitizeName(fs.name);
        oname := fs.name;
        oe := FSpDirCreate(fs, 0, dirID);
        i := 1;
        while oe = dupFNErr do begin
            NumToString(i, n);
            fs.name := concat(copy(oname, 1, 27), '#', n);
            oe := FSpDirCreate(fs, 0, dirID);
            i := i + 1;
        end;
        CreateUniqueDir := oe;
    end;

    function MyFSWrite (rn: integer; count: longInt; p: ptr): OSErr;
        var
            oe: OSErr;
            c: longInt;
    begin
        c := count;
        oe := FSWrite(rn, c, p);
        if (oe = noErr) & (count <> c) then
            oe := -1;
        MyFSWrite := oe;
    end;

    function MyFSRead (rn: integer; count: longInt; p: ptr): OSErr;
        var
            oe: OSErr;
            c: longInt;
    begin
        c := count;
        oe := FSRead(rn, c, p);
        if (oe = noErr) & (count <> c) then
            oe := -1;
        MyFSRead := oe;
    end;

{ WARNING: Beware of overuse of records pb, fs, start, comment, and header.  This is a recursive routine }
{ so I am ver frugal on stack usage, and consiquently, its very dangerous - tread lightly }
{ The same it true for endblock and zeropacket, but since they are static it doesnt matter so much }
    procedure DecodeFile (rn: integer; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
        const
            errEndBlock = 2;
        var
            pb: CInfoPBRec;
            start: MBIIStartHeader;
            comment: str255;
            header: MBIIHeader;
            inafolder: boolean;
            clearflags: integer;
        function DF: OSErr;
            function ReadPad (count: longInt): OSErr;
                var
                    oe: OSErr;
                    space: MBIIHeader;
            begin
                oe := noErr;
                count := count mod 128;
                if count > 0 then begin
                    count := 128 - count;
                    oe := MyFSRead(rn, count, @space);
                    display_done := display_done + count;
                end;
                ReadPad := oe;
            end;

            function ReadComment (len: integer): OSErr;
                var
                    oe: OSErr;
            begin
                if len = 0 then
                    oe := noErr
                else
                    oe := MyFSRead(rn, len, @comment[1]);
                display_done := display_done + len;
                if oe = noErr then
                    oe := ReadPad(len);
                ReadComment := oe;
            end;

            function DoFile: OSErr;
                function ReadFork (orn: integer; len: longInt): OSErr;
                    var
                        oe: OSErr;
                        olen, count: longInt;
                begin
                    oe := noErr;
                    olen := len;
                    while (oe = noErr) & (len > 0) do begin
                        count := len;
                        if count > bufsiz then
                            count := bufsiz;
                        Yield;
                        oe := MyFSRead(rn, count, bufferp);
                        display_done := display_done + count;
                        if oe = noErr then
                            oe := MyFSWrite(orn, count, bufferp);
                        len := len - count;
                    end;
                    if oe = noErr then
                        oe := ReadPad(olen);
                    ReadFork := oe;
                end;
                var
                    i, orn: integer;
                    count: longInt;
                    oe, ooe: OSErr;
            begin
                fs.name := start.name;

                oe := noErr;
                if not inafolder and launchedwithoption then begin
                    if not GetOutput(fs) then
                        oe := abortError;
                end;
                if oe = noErr then
                    oe := CreateUniqueFile(fs, start.fcreator, start.ftype);

                if start.dlen > 0 then begin
                    oe := FSpOpenDF(fs, fsRdWrPerm, orn);
                    if oe = noErr then begin
                        oe := ReadFork(orn, start.dlen);
                        ooe := FSClose(orn);
                    end;
                end;

                if (oe = noErr) and (start.rlen > 0) then begin
                    oe := FSpOpenRF(fs, fsRdWrPerm, orn);
                    if oe = noErr then begin
                        oe := ReadFork(orn, start.rlen);
                        ooe := FSClose(orn);
                    end;
                end;

                Yield;

                if oe = noErr then
                    oe := ReadComment(start.clen);
                if oe = noErr then
                    SetDTDBComment(dtrn, fs, comment);

                if oe = noErr then begin
                    pb.ioNamePtr := @fs.name;
                    pb.ioVRefNum := fs.vRefNum;
                    pb.ioFDirIndex := 0;
                    pb.ioDirID := fs.parID;
                    ooe := PBGetCatInfo(@pb, false);
                    if ooe = noErr then begin
                        pb.ioNamePtr := @fs.name;
                        pb.ioVRefNum := fs.vRefNum;
                        pb.ioFDirIndex := 0;
                        pb.ioDirID := fs.parID;
                        pb.ioFlFndrInfo.fdType := start.ftype;
                        pb.ioFlFndrInfo.fdCreator := start.fcreator;
                        pb.ioFlFndrInfo.fdFlags := BOR(BAND(BSL(start.flags_high, 8), $FF00), BAND(start.flags_low, $00FF));
                        pb.ioFlFndrInfo.fdFlags := BXOR(BOR(pb.ioFlFndrInfo.fdFlags, clearflags), clearflags);
                        if inafolder then
                            pb.ioFlFndrInfo.fdLocation := start.flocation;
                        pb.ioFlCrDat := start.create_date;
                        pb.ioFlMdDat := start.mod_date;
                        ooe := PBSetCatInfo(@pb, false);
                    end;
                end;

                DoFile := oe;
            end;

            function DoFolder: OSErr;
                var
                    ocrc, i, irn: integer;
                    count: longInt;
                    oe, ooe: OSErr;
                    index, vrn: integer;
                    dirID: longInt;
            begin
                fs.name := start.name;
                vrn := fs.vRefNum;
                oe := noErr;
                if not inafolder and launchedwithoption then begin
                    if not GetOutput(fs) then
                        oe := abortError;
                end;
                if oe = noErr then
                    oe := CreateUniqueDir(fs, dirID);

                if oe = noErr then
                    oe := ReadComment(start.clen);
                if oe = noErr then
                    SetDTDBComment(dtrn, fs, comment);

                if oe = noErr then begin
                    pb.ioNamePtr := @fs.name;
                    pb.ioVRefNum := fs.vRefNum;
                    pb.ioFDirIndex := 0;
                    pb.ioDirID := fs.parID;
                    ooe := PBGetCatInfo(@pb, false);
                    if ooe = noErr then begin
                        pb.ioNamePtr := @fs.name;
                        pb.ioVRefNum := fs.vRefNum;
                        pb.ioFDirIndex := 0;
                        pb.ioDirID := fs.parID;
                        pb.ioFlFndrInfo.fdFlags := BOR(BAND(BSL(start.flags_high, 8), $FF00), BAND(start.flags_low, $00FF));
                        pb.ioFlFndrInfo.fdFlags := BXOR(BOR(pb.ioFlFndrInfo.fdFlags, clearflags), clearflags);
                        if inafolder then
                            pb.ioFlFndrInfo.fdLocation := start.flocation;
                        pb.ioFlCrDat := start.create_date;
                        pb.ioFlMdDat := start.mod_date;
                        ooe := PBSetCatInfo(@pb, false);
                    end;
                end;
                inafolder := true;
                clearflags := clear_flags;

                if oe = noErr then begin
                    repeat
                        fs.vRefNum := vrn;
                        fs.parID := dirID;
                        oe := DF;
                    until (oe <> noErr);
                    if oe = errEndBlock then
                        oe := noErr;
                end;

                DoFolder := oe;
            end;
            var
                oe: OSErr;
                typ: packet_type;
        begin
            oe := MyFSRead(rn, SizeOf(header), @header);
            display_done := display_done + SizeOf(header);
            BlockMove(@header.MBIIStart, @start, SizeOf(start));
            if oe = noErr then
                typ := ValidateMBHeader(header, true)
            else
                typ := PT_None;
            case typ of
                PT_File:
                    oe := DoFile;
                PT_StartBlock:
                    oe := DoFolder;
                PT_EndBlock:
                    oe := errEndBlock;
                otherwise
                    oe := errFormatError;
            end;
            DF := oe;
        end;
        var
            oe: OSErr;
            len: longInt;
    begin
        inafolder := false;
        clearflags := clear_flags + fdInited;
        oe := GetEOF(rn, len);
        if oe = noErr then
            display_total := display_total + len;
        oe := DF;
        if oe <> noErr then
            FailError(oe);
    end;

{ WARNING: Beware of overuse of records pb, fs, start, comment, and header.  This is a recursive routine }
{ so I am very frugal on stack usage, and consiquently, its very dangerous - tread lightly }
{ The same it true for endblock and zeropacket, but since they are static it doesnt matter so much }
    function EncodeToFile (var pb: CInfoPBRec; var fs: FSSpec; rn, dtrn: integer; bufferp: ptr; bufsiz: longInt): OSErr;
        const
            display_folder_size = 1000;
        var
            start: MBIIStartHeader;
            comment: str255;
            header: MBIIHeader;
            endblock: MBIIHeader;
            zeropacket: MBpacket;
        function ETF: OSErr;
            function WritePad (count: longInt): OSErr;
                var
                    oe: OSErr;
            begin
                oe := noErr;
                count := count mod 128;
                if count > 0 then begin
                    count := 128 - count;
                    oe := MyFSWrite(rn, count, @zeropacket);
                end;
                WritePad := oe;
            end;

            function WriteComment: OSErr;
                var
                    count: longInt;
                    oe: OSErr;
            begin
                count := length(comment);
                oe := MyFSWrite(rn, count, @comment[1]);
                if oe = noErr then
                    oe := WritePad(count);
                WriteComment := oe;
            end;

            function DoFile: OSErr;
                function WriteFork (irn: integer; len: longInt): OSErr;
                    var
                        oe: OSErr;
                        olen, count: longInt;
                begin
                    oe := noErr;
                    olen := len;
                    while (oe = noErr) & (len > 0) do begin
                        Yield;
                        count := len;
                        if count > bufsiz then
                            count := bufsiz;
                        oe := MyFSRead(irn, count, bufferp);
                        if oe = noErr then
                            oe := MyFSWrite(rn, count, bufferp);
                        display_done := display_done + count;
                        len := len - count;
                    end;
                    if oe = noErr then
                        oe := WritePad(olen);
                    WriteFork := oe;
                end;
                var
                    ocrc, i, irn: integer;
                    count: longInt;
                    oe, ooe: OSErr;
            begin
                fs.vRefNum := pb.ioVRefNum;
                fs.parID := pb.ioFlParID;
                fs.name := pb.ioNamePtr^;
                MFillLong(@header, SizeOf(header), 0);
                MFill(@start, SizeOf(start), 0);
                header.versionII := 129;
                header.minversionII := 129;
                start.name := fs.name;
                start.ftype := pb.ioFlFndrInfo.fdType;
                start.fcreator := pb.ioFlFndrInfo.fdCreator;
                start.flags_high := BAND(BSR(pb.ioFlFndrInfo.fdFlags, 8), $FF);
                start.flags_low := BAND(pb.ioFlFndrInfo.fdFlags, $FF);
                start.flocation := pb.ioFlFndrInfo.fdLocation;
                start.windowID := pb.ioFlFndrInfo.fdFldr;
                start.dlen := pb.ioFlLgLen;
                start.rlen := pb.ioFlRLgLen;
                start.create_date := pb.ioFlCrDat;
                start.mod_date := pb.ioFlMdDat;
                GetDTDBComment(dtrn, fs, comment);
                start.clen := length(comment);
                BlockMove(@start, @header.MBIIStart, SizeOf(start));
                ocrc := 0;
                for i := 1 to 124 do
                    CalcMBCRC(ocrc, MBPacket(header)[i]);
                header.crc := ocrc;
                count := SizeOf(header);
                oe := MyFSWrite(rn, count, @header);
                Yield;
                if oe = noErr then begin
                    oe := FSpOpenDF(fs, fsRdPerm, irn);
                    if oe = noErr then begin
                        oe := WriteFork(irn, pb.ioFlLgLen);
                        ooe := FSClose(irn);
                        if oe = noErr then
                            oe := FSpOpenRF(fs, fsRdPerm, irn);
                        if oe = noErr then begin
                            oe := WriteFork(irn, pb.ioFlRLgLen);
                            ooe := FSClose(irn);
                            Yield;
                            oe := WriteComment;
                        end;
                    end;
                end;
                DoFile := oe;
            end;

            function DoFolder: OSErr;
                var
                    ocrc, i, irn: integer;
                    count: longInt;
                    oe, ooe: OSErr;
                    index, vrn: integer;
                    dirID: longInt;
            begin
                fs.vRefNum := pb.ioVRefNum;
                fs.parID := pb.ioDrDirID;
                fs.name := pb.ioNamePtr^;
                MFillLong(@header, SizeOf(header), 0);
                MFill(@start, SizeOf(start), 0);
                header.version := 1;
                header.versionII := 130;
                header.minversionII := 130;
                start.name := fs.name;
                start.ftype := macbin_folder_ftype;
                start.fcreator := OSType(macbin_folder_creator_start);
                start.flags_high := BAND(BSR(pb.ioFlFndrInfo.fdFlags, 8), $FF);
                start.flags_low := BAND(pb.ioFlFndrInfo.fdFlags, $FF);
                start.flocation := pb.ioFlFndrInfo.fdLocation;
                start.windowID := pb.ioFlFndrInfo.fdFldr;
                start.dlen := 0;
                start.rlen := 0;
                start.create_date := pb.ioFlCrDat;
                start.mod_date := pb.ioFlMdDat;
                GetDTDBComment(dtrn, fs, comment);
                start.clen := length(comment);
                BlockMove(@start, @header.MBIIStart, SizeOf(start));
                ocrc := 0;
                for i := 1 to 124 do
                    CalcMBCRC(ocrc, MBPacket(header)[i]);
                header.crc := ocrc;
                count := SizeOf(header);
                oe := MyFSWrite(rn, count, @header);
                if oe = noErr then
                    oe := WriteComment;
                Yield;
                if oe = nOErr then begin
                    index := 1;
                    dirID := pb.ioDirID;
                    vrn := pb.ioVRefNum;
                    repeat
                        fs.name := '';
                        pb.ioNamePtr := @fs.name;
                        pb.ioVRefNum := vrn;
                        pb.ioFDirIndex := index;
                        index := index + 1;
                        pb.ioDirID := dirID;
                        oe := PBGetCatInfo(@pb, false);
                        if oe = fnfErr then begin
                            oe := noErr;
                            leave;
                        end;
                        if oe = noErr then
                            oe := ETF;
                    until oe <> noErr;
                    if oe = noErr then begin
                        count := SizeOf(endblock);
                        oe := MyFSWrite(rn, count, @endblock);
                    end;
                    display_done := display_done + display_folder_size;
                end;
                DoFolder := oe;
            end;
        begin
            if BAND(pb.ioFlAttrib, $0010) = 0 then begin
                ETF := DoFile;
            end
            else begin
                ETF := DoFolder;
            end;
        end;

        var
            ppb: CInfoPBRec;
            pname: str63;
        function PreScan: OSErr;
            var
                oe: OSErr;
                index, vrn: integer;
                dirID: longInt;
        begin
            if BAND(ppb.ioFlAttrib, $0010) = 0 then begin
                display_total := display_total + ppb.ioFlLgLen + ppb.ioFlRLgLen;
                oe := noErr;
            end
            else begin
                Yield;
                display_total := display_total + display_folder_size;
                index := 1;
                dirID := ppb.ioDirID;
                vrn := ppb.ioVRefNum;
                repeat
                    pname := '';
                    ppb.ioNamePtr := @pname;
                    ppb.ioVRefNum := vrn;
                    ppb.ioFDirIndex := index;
                    index := index + 1;
                    ppb.ioDirID := dirID;
                    oe := PBGetCatInfo(@ppb, false);
                    if oe = fnfErr then begin
                        oe := noErr;
                        leave;
                    end;
                    if oe = noErr then
                        oe := PreScan;
                until oe <> noErr;
            end;
            PreScan := oe;
        end;

        var
            i, ocrc: integer;
            oe: OSErr;
    begin
        MFillLong(@zeropacket, SizeOf(zeropacket), 0); { used for padding }
        MFillLong(@endblock, SizeOf(endblock), 0);
        MFill(@start, SizeOf(start), 0);
        endblock.version := 1;
        start.ftype := macbin_folder_ftype;
        start.fcreator := OSType(macbin_folder_creator_end);
        BlockMove(@start, @endblock.MBIIStart, SizeOf(start));
        endblock.versionII := 130;
        endblock.minversionII := 130;
        ocrc := 0;
        for i := 1 to 124 do
            CalcMBCRC(ocrc, MBPacket(endblock)[i]);
        endblock.crc := ocrc;
        ppb := pb;
        oe := PreScan; { Sigh, I hate progress bars! }
        EncodeToFile := ETF;
    end;

    procedure EncodeFileFolder (var pb: CInfoPBRec; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
        var
            dst: FSSpec;
            rn: integer;
            oe, ooe: OSErr;
            doit: boolean;
    begin
        oe := noErr;
        doit := true;
        dst := fs;
        if copy(dst.name, length(dst.name) - 2, 2) = ' ƒ' then
            dst.name := copy(dst.name, 1, length(dst.name) - 2);
        dst.name := concat(dst.name, '.bin');
        if launchedwithoption then begin
            doit := GetOutput(dst);
        end;
        if doit then begin
            oe := CreateUniqueFile(dst, macbin_creator, macbin_ftype);
            if oe = noErr then begin
                oe := FSpOpenDF(dst, fsRdWrPerm, rn);
                if oe = noErr then begin
                    oe := EncodeToFile(pb, fs, rn, dtrn, bufferp, bufsiz);
                    ooe := FSClose(rn);
                end;
            end;
        end;
        MDisposePtr(bufferp);
        if oe <> noErr then
            FailError(oe);
    end;

    procedure CheckFile (var pb: CInfoPBRec; var fs: FSSpec; dtrn: integer; bufferp: ptr; bufsiz: longInt);
        var
            isbin: boolean;
            rn: integer;
            oe, ooe: OSErr;
            header: MBIIHeader;
            count: longInt;
    begin
        isbin := false;
        if (pb.ioFlLgLen > 128) then begin
            oe := FSpOpenDF(fs, fsRdPerm, rn);
            if oe = noErr then begin
                oe := MyFSRead(rn, SizeOf(header), @header);
                if (oe = noErr) & (ValidateMBHeader(header, true) <> PT_None) then begin
                    oe := SetFPos(rn, fsFromStart, 0);
                    if oe = noErr then begin
                        DecodeFile(rn, fs, dtrn, bufferp, bufsiz);
                    end;
                    isbin := true;
                end;
                oe := FSClose(rn);
            end;
        end;

        if not isbin then
            EncodeFileFolder(pb, fs, dtrn, bufferp, bufsiz);
    end;

    procedure DoFile (fsp: FSSpecPtr);
        var
            dst: FSSPec;
            pb: CInfoPBRec;
            oe: OSErr;
            dtrn: integer;
            bufferp: ptr;
            bufsiz, t: longInt;
    begin
        files := files + 1;
        quitWhenDone := true;
        quitNow := true;

        oe := GetDesktopDB(fsp^.vRefNum, dtrn); { ignore error }
        PurgeSpace(t, bufsiz);
        bufsiz := bufsiz div 3;
        MNewPtr(bufferp, bufsiz);
        oe := MemError;
        if bufferp <> nil then begin
            with pb do begin
                ioNamePtr := @fsp^.name;
                ioVRefNum := fsp^.vRefNum;
                ioDirID := fsp^.parID;
                ioFDirIndex := 0;
            end;
            oe := PBGetCatInfo(@pb, false);
            if oe = noErr then begin
                if BAND(pb.ioFlAttrib, $0010) = 0 then
                    CheckFile(pb, fsp^, dtrn, bufferp, bufsiz)
                else begin
                    EncodeFileFolder(pb, fsp^, dtrn, bufferp, bufsiz);
                end;
            end;
        end;

        files := files - 1;
        MDisposePtr(fsp);
    end;

    function DoODoc (fs: FSSpec): OSErr;
        var
            trn: integer;
            p: FSSpecPtr;
            oe: OSErr;
    begin
        MNewPtr(p, SizeOf(FSSpec));
        oe := MemError;
        if p <> nil then begin
            p^ := fs;
            oe := NewTask(@DoFile, nil, p, trn);
        end;
        DoODoc := oe;
    end;

    var
        oe, ooe: OSErr;
        gv: longInt;
        er: eventRecord;
        dummy: boolean;
begin
    dummy := OSEventAvail(everyEvent, er);
    launchedwithoption := BAND(er.modifiers, optionKey) <> 0;
    oe := Gestalt(gestaltAppleEventsAttr, gv);
    has_AppleEvents := (oe = noErr) and (BTST(gv, gestaltAppleEventsPresent));
    quitNow := false;
    quitWhenDone := false;
    files := 0;
    if has_AppleEvents & (InitAppleEvents(@DOOApp, @DoODoc, nil, @DoQuit) = noErr) then begin
        InitDisplay;
        if InitTasking = noErr then begin

            while not quitNow or (quitWhenDone and (files > 0)) do begin
                if WaitNextEvent(everyEvent, er, 3, nil) then begin
                    case er.what of
                        keyDown:
                            quitNow := true;
                        updateEvt:  begin
                            BeginUpdate(windowPtr(er.message));
                            UpdateDisplay;
                            EndUpdate(windowPtr(er.message));
                        end;
                        kHighLevelEvent:
                            if has_AppleEvents then
                                oe := AEProcessAppleEvent(er);
                        otherwise
                            ;
                    end;
                end;
        { Allow tasks to run for a while }
                oe := RunTasks(1);
                UpdateDisplay;
            end;

            ooe := TermTasking;
        end;
        FinishDisplay;
    end;
end.